home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / pcl-rev4.lha / braid.lisp < prev    next >
Lisp/Scheme  |  1990-12-05  |  18KB  |  523 lines
  1. ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; Bootstrapping the meta-braid.
  28. ;;;
  29. ;;; The code in this file takes the early definitions that have been saved
  30. ;;; up and actually builds those class objects.  This work is largely driven
  31. ;;; off of those class definitions, but the fact that STANDARD-CLASS is the
  32. ;;; class of all metaclasses in the braid is built into this code pretty
  33. ;;; deeply.
  34. ;;;
  35. ;;; 
  36.  
  37. (in-package 'pcl)
  38.  
  39. (defun early-class-definition (class-name)
  40.   (or (find class-name *early-class-definitions* :key #'ecd-class-name)
  41.       (error "~S is not a class in *early-class-definitions*." class-name)))
  42.  
  43. (defun canonical-slot-name (canonical-slot)
  44.   (getf canonical-slot :name))
  45.  
  46. (defun early-collect-inheritance (class-name)
  47.   (declare (values slots cpl default-initargs direct-subclasses))
  48.   (let ((cpl (early-collect-cpl class-name)))
  49.     (values (early-collect-slots cpl)
  50.         cpl
  51.         (early-collect-default-initargs cpl)
  52.         (gathering1 (collecting)
  53.           (dolist (definition *early-class-definitions*)
  54.         (when (memq class-name (ecd-superclass-names definition))
  55.           (gather1 (ecd-class-name definition))))))))
  56.  
  57. (defun early-collect-cpl (class-name)
  58.   (labels ((walk (c)
  59.          (let* ((definition (early-class-definition c))
  60.             (supers (ecd-superclass-names definition)))
  61.            (cons c
  62.              (apply #'append (mapcar #'early-collect-cpl supers))))))
  63.     (remove-duplicates (walk class-name) :from-end nil :test #'eq)))
  64.  
  65. (defun early-collect-slots (cpl)
  66.   (let* ((definitions (mapcar #'early-class-definition cpl))
  67.      (super-slots (mapcar #'ecd-canonical-slots definitions))
  68.      (slots (apply #'append (reverse super-slots))))
  69.     (dolist (s1 slots)
  70.       (let ((name1 (canonical-slot-name s1)))
  71.     (dolist (s2 (cdr (memq s1 slots)))
  72.       (when (eq name1 (canonical-slot-name s2))
  73.         (error "More than one early class defines a slot with the~%~
  74.                     name ~S.  This can't work because the bootstrap~%~
  75.                     object system doesn't know how to compute effective~%~
  76.                     slots."
  77.            name1)))))
  78.     slots))
  79.  
  80. (defun early-collect-default-initargs (cpl)
  81.   (let ((default-initargs ()))
  82.     (dolist (class-name cpl)
  83.       (let ((definition (early-class-definition class-name)))
  84.     (dolist (option (ecd-other-initargs definition))
  85.       (unless (eq (car option) :default-initargs)
  86.         (error "The defclass option ~S is not supported by the bootstrap~%~
  87.                     object system."
  88.            (car option)))
  89.       (setq default-initargs
  90.         (nconc default-initargs (reverse (cdr option)))))))
  91.     (reverse default-initargs)))
  92.  
  93.  
  94. ;;;
  95. ;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change
  96. ;;; the values of slots during bootstrapping.  During bootstrapping, there
  97. ;;; are only two kinds of objects whose slots we need to access, CLASSes
  98. ;;; and SLOTDs.  The first argument to these functions tells whether the
  99. ;;; object is a CLASS or a SLOTD.
  100. ;;;
  101. ;;; Note that the way this works it stores the slot in the same place in
  102. ;;; memory that the full object system will expect to find it later.  This
  103. ;;; is critical to the bootstrapping process, the whole changeover to the
  104. ;;; full object system is predicated on this.
  105. ;;;
  106. ;;; One important point is that the layout of standard classes and standard
  107. ;;; slots must be computed the same way in this file as it is by the full
  108. ;;; object system later.
  109. ;;; 
  110. (defun bootstrap-get-slot (type object slot-name)
  111.   (let ((index (bootstrap-slot-index type slot-name)))
  112.     (svref (std-instance-slots object) index)))
  113.  
  114. (defun bootstrap-set-slot (type object slot-name new-value)
  115.   (let ((index (bootstrap-slot-index type slot-name)))
  116.     (setf (svref (std-instance-slots object) index) new-value)))
  117.  
  118. (defvar *std-class-slots*
  119.     (mapcar #'canonical-slot-name
  120.         (early-collect-inheritance 'standard-class)))
  121.  
  122. (defvar *bin-class-slots*
  123.     (mapcar #'canonical-slot-name
  124.         (early-collect-inheritance 'built-in-class)))
  125.  
  126. (defvar *std-slotd-slots*
  127.     (mapcar #'canonical-slot-name
  128.         (early-collect-inheritance 'standard-slot-definition)))
  129.  
  130. (defun bootstrap-slot-index (type slot-name)
  131.   (or (position slot-name (ecase type
  132.                 (std-class *std-class-slots*)
  133.                 (bin-class *bin-class-slots*)
  134.                 (std-slotd *std-slotd-slots*)))
  135.       (error "~S not found" slot-name)))
  136.  
  137.  
  138. ;;;
  139. ;;; bootstrap-meta-braid
  140. ;;;
  141. ;;; This function builds the base metabraid from the early class definitions.
  142. ;;;   
  143. (defun bootstrap-meta-braid ()
  144.   (let* ((std-class-size (length *std-class-slots*))
  145.          (std-class (%allocate-instance--class std-class-size))
  146.          (std-class-wrapper (make-wrapper std-class))
  147.      (built-in-class (%allocate-instance--class std-class-size))
  148.      (built-in-class-wrapper (make-wrapper built-in-class))
  149.      (direct-slotd    (%allocate-instance--class std-class-size))
  150.      (effective-slotd (%allocate-instance--class std-class-size))
  151.      (direct-slotd-wrapper    (make-wrapper direct-slotd))
  152.      (effective-slotd-wrapper (make-wrapper effective-slotd)))
  153.     ;;
  154.     ;; First, make a class metaobject for each of the early classes.  For
  155.     ;; each metaobject we also set its wrapper.  Except for the class T,
  156.     ;; the wrapper is always that of STANDARD-CLASS.
  157.     ;; 
  158.     (dolist (definition *early-class-definitions*)
  159.       (let* ((name (ecd-class-name definition))
  160.          (meta (ecd-metaclass definition))
  161.              (class (case name
  162.                       (standard-class                     std-class)
  163.                       (standard-direct-slot-definition    direct-slotd)
  164.               (standard-effective-slot-definition effective-slotd)
  165.               (built-in-class                     built-in-class)
  166.                       (otherwise
  167.             (%allocate-instance--class std-class-size)))))
  168.     (unless (eq name t)
  169.       (inform-type-system-about-class class name))
  170.     (setf (std-instance-wrapper class)
  171.           (ecase meta
  172.         (standard-class std-class-wrapper)
  173.         (built-in-class built-in-class-wrapper)))
  174.         (setf (find-class name) class)))
  175.     ;;
  176.     ;;
  177.     ;;
  178.     (dolist (definition *early-class-definitions*)
  179.       (let ((name (ecd-class-name definition))
  180.         (source (ecd-source definition))
  181.         (direct-supers (ecd-superclass-names definition))
  182.         (direct-slots  (ecd-canonical-slots definition))
  183.         (other-initargs (ecd-other-initargs definition)))
  184.     (let ((direct-default-initargs
  185.         (getf other-initargs :default-initargs)))
  186.       (multiple-value-bind (slots cpl default-initargs direct-subclasses)
  187.           (early-collect-inheritance name)
  188.         (let* ((class (find-class name))
  189.            (wrapper
  190.              (cond
  191.                ((eq class std-class)       std-class-wrapper)
  192.                ((eq class direct-slotd)    direct-slotd-wrapper)
  193.                ((eq class effective-slotd) effective-slotd-wrapper)
  194.                ((eq class built-in-class)  built-in-class-wrapper)
  195.                (t (make-wrapper class))))
  196.            (proto nil))
  197.           (cond ((eq name 't)
  198.              (setq *the-wrapper-of-t* wrapper
  199.                *the-class-t* class))
  200.             ((memq name '(standard-object 
  201.                   standard-class
  202.                   standard-effective-slot-definition))
  203.              (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
  204.                   *the-pcl-package*)
  205.               class)))
  206.           (dolist (slot slots)
  207.         (unless (eq (getf slot :allocation :instance) :instance)
  208.           (error "Slot allocation ~S not supported in bootstrap.")))
  209.           
  210.           (setf (wrapper-instance-slots-layout wrapper)
  211.             (mapcar #'canonical-slot-name slots))
  212.           (setf (wrapper-class-slots wrapper)
  213.             ())
  214.           
  215.           (setq proto (%allocate-instance--class (length slots)))
  216.           (setf (std-instance-wrapper proto) wrapper)
  217.         
  218.           (setq direct-slots
  219.             (bootstrap-make-slot-definitions name direct-slots
  220.                              direct-slotd-wrapper nil))
  221.           (setq slots
  222.             (bootstrap-make-slot-definitions name slots
  223.                              effective-slotd-wrapper t))
  224.           
  225.           (bootstrap-initialize-std-class
  226.         class name source
  227.         direct-supers direct-subclasses cpl wrapper
  228.         direct-slots slots direct-default-initargs default-initargs
  229.         proto)
  230.           
  231.           (dolist (slotd direct-slots)
  232.         (bootstrap-accessor-definitions
  233.           name
  234.           (bootstrap-get-slot 'std-slotd slotd 'name)
  235.           (bootstrap-get-slot 'std-slotd slotd 'readers)
  236.           (bootstrap-get-slot 'std-slotd slotd 'writers))))))))))
  237.  
  238. (defun bootstrap-accessor-definitions (class-name slot-name readers writers)
  239.   (flet ((do-reader-definition (reader)
  240.        (add-method
  241.          (ensure-generic-function reader)
  242.          (make-a-method
  243.            'standard-reader-method
  244.            ()
  245.            (list class-name)
  246.            (list class-name)
  247.            (make-std-reader-method-function slot-name)
  248.            "automatically generated reader method"
  249.            slot-name)))
  250.      (do-writer-definition (writer)
  251.        (add-method
  252.          (ensure-generic-function writer)
  253.          (make-a-method
  254.            'standard-writer-method
  255.            ()
  256.            (list 'new-value class-name)
  257.            (list 't class-name)
  258.            (make-std-writer-method-function slot-name)
  259.            "automatically generated writer method"
  260.            slot-name))))
  261.     (dolist (reader readers) (do-reader-definition reader))
  262.     (dolist (writer writers) (do-writer-definition writer))))
  263.  
  264. ;;;
  265. ;;; Initialize a standard class metaobject.
  266. ;;;
  267. (defun bootstrap-initialize-std-class
  268.        (class
  269.     name definition-source direct-supers direct-subclasses cpl wrapper
  270.     direct-slots slots direct-default-initargs default-initargs proto)
  271.   (flet ((classes (names) (mapcar #'find-class names))
  272.      (set-slot (slot-name value)
  273.        (bootstrap-set-slot 'std-class class slot-name value)))
  274.     
  275.     (set-slot 'name name)
  276.     (set-slot 'source definition-source)
  277.     (set-slot 'class-precedence-list (classes cpl))
  278.     (set-slot 'direct-superclasses (classes direct-supers))
  279.     (set-slot 'direct-slots direct-slots)
  280.     (set-slot 'direct-subclasses (classes direct-subclasses))
  281.     (set-slot 'direct-methods (cons nil nil))
  282.     (set-slot 'no-of-instance-slots (length slots))
  283.     (set-slot 'slots slots)
  284.     (set-slot 'wrapper wrapper)
  285.     (set-slot 'prototype proto)
  286.     (set-slot 'plist
  287.           `(,@(and direct-default-initargs
  288.                `(direct-default-initargs ,direct-default-initargs))
  289.         ,@(and default-initargs
  290.                `(default-initargs ,default-initargs))))
  291.     ))
  292.  
  293. ;;;
  294. ;;; Initialize a built-in-class metaobject.
  295. ;;;
  296. (defun bootstrap-initialize-bin-class
  297.        (class
  298.     name definition-source direct-supers direct-subclasses cpl wrapper)
  299.   (flet ((classes (names) (mapcar #'find-class names))
  300.      (set-slot (slot-name value)
  301.        (bootstrap-set-slot 'bin-class class slot-name value)))
  302.     
  303.     (set-slot 'name name)
  304.     (set-slot 'source definition-source)
  305.     (set-slot 'direct-superclasses (classes direct-supers))
  306.     (set-slot 'direct-subclasses (classes direct-subclasses))
  307.     (set-slot 'direct-methods (cons nil nil))
  308.     (set-slot 'class-precedence-list (classes cpl))
  309.     (set-slot 'wrapper wrapper)))
  310.  
  311. (defun bootstrap-make-slot-definitions (name slots wrapper e-p)
  312.   (mapcar #'(lambda (slot) (bootstrap-make-slot-definition name slot wrapper e-p))
  313.           slots))
  314.  
  315. (defun bootstrap-make-slot-definition (name slot wrapper e-p)  
  316.   (let ((slotd (%allocate-instance--class (length *std-slotd-slots*))))
  317.     (setf (std-instance-wrapper slotd) wrapper)
  318.     (flet ((get-val (name) (getf slot name))
  319.        (set-val (name val) (bootstrap-set-slot 'std-slotd slotd name val)))
  320.       (set-val 'name         (get-val :name))
  321.       (set-val 'initform     (get-val :initform))
  322.       (set-val 'initfunction (get-val :initfunction))      
  323.       (set-val 'initargs     (get-val :initargs))
  324.       (set-val 'readers      (get-val :readers))
  325.       (set-val 'writers      (get-val :writers))
  326.       (set-val 'allocation   :instance)
  327.       (set-val 'type         (get-val :type))
  328.       (set-val 'class        nil)
  329.       (set-val 'instance-index nil)
  330.       (when (and (eq name 'standard-class) (eq (get-val :name) 'slots) e-p)
  331.     (setq *the-eslotd-standard-class-slots* slotd))
  332.       slotd)))
  333.  
  334. (defun bootstrap-built-in-classes ()
  335.   ;;
  336.   ;; First make sure that all the supers listed in *built-in-class-lattice*
  337.   ;; are themselves defined by *built-in-class-lattice*.  This is just to
  338.   ;; check for typos and other sorts of brainos.
  339.   ;; 
  340.   (dolist (e *built-in-classes*)
  341.     (dolist (super (cadr e))
  342.       (unless (or (eq super 't)
  343.           (assq super *built-in-classes*))
  344.     (error "In *built-in-classes*: ~S has ~S as a super,~%~
  345.                 but ~S is not itself a class in *built-in-classes*."
  346.            (car e) super super))))
  347.  
  348.   ;;
  349.   ;; In the first pass, we create a skeletal object to be bound to the
  350.   ;; class name.
  351.   ;;
  352.   (let* ((built-in-class (find-class 'built-in-class))
  353.      (built-in-class-wrapper (class-wrapper built-in-class))
  354.      (bin-class-size (length *bin-class-slots*)))
  355.     (dolist (e *built-in-classes*)
  356.       (let ((class (%allocate-instance--class bin-class-size)))
  357.     (setf (std-instance-wrapper class) built-in-class-wrapper)
  358.     (setf (find-class (car e)) class))))
  359.  
  360.   ;;
  361.   ;; In the second pass, we initialize the class objects.
  362.   ;;
  363.   (dolist (e *built-in-classes*)
  364.     (destructuring-bind (name supers subs cpl) e
  365.       (let* ((class (find-class name))
  366.          (wrapper (make-wrapper class)))
  367.     (set (get-built-in-class-symbol name) class)
  368.     (set (get-built-in-wrapper-symbol name) wrapper)
  369.  
  370.     (setf (wrapper-instance-slots-layout wrapper) ()
  371.           (wrapper-class-slots wrapper) ())
  372.  
  373.     (bootstrap-initialize-bin-class class
  374.                     name nil
  375.                     supers subs
  376.                     (cons name cpl) wrapper)
  377.     ))))
  378.  
  379.  
  380. ;;;
  381. ;;;
  382. ;;;
  383.  
  384. (defun class-of (x) (wrapper-class (wrapper-of x)))
  385.  
  386. (defun wrapper-of (x) 
  387.   (or (and (std-instance-p x)
  388.        (std-instance-wrapper x))
  389.       (and (fsc-instance-p x)
  390.        (fsc-instance-wrapper x))
  391.       (built-in-wrapper-of x)
  392.       (error "Can't determine wrapper of ~S" x)))
  393.  
  394.  
  395. (eval-when (compile eval)
  396.  
  397. (defun make-built-in-class-subs ()
  398.   (mapcar #'(lambda (e)
  399.           (let ((class (car e))
  400.             (class-subs ()))
  401.         (dolist (s *built-in-classes*)
  402.           (when (memq class (cadr s)) (pushnew (car s) class-subs)))
  403.         (cons class class-subs)))
  404.       (cons '(t) *built-in-classes*)))
  405.  
  406. (defun make-built-in-class-tree ()
  407.   (let ((subs (make-built-in-class-subs)))
  408.     (labels ((descend (class)
  409.            (cons class (mapcar #'descend (cdr (assq class subs))))))
  410.       (descend 't))))
  411.  
  412. (defun make-built-in-wrapper-of-body ()
  413.   (make-built-in-wrapper-of-body-1 (make-built-in-class-tree)
  414.                    'x
  415.                    #'get-built-in-wrapper-symbol))
  416.  
  417. (defun make-built-in-wrapper-of-body-1 (tree var get-symbol)
  418.   (let ((*specials* ()))
  419.     (declare (special *specials*))
  420.     (let ((inner (make-built-in-wrapper-of-body-2 tree var get-symbol)))
  421.       `(locally (declare (special .,*specials*)) ,inner))))
  422.  
  423. (defun make-built-in-wrapper-of-body-2 (tree var get-symbol)
  424.   (declare (special *specials*))
  425.   (let ((symbol (funcall get-symbol (car tree))))
  426.     (push symbol *specials*)
  427.     (let ((sub-tests
  428.         (mapcar #'(lambda (x)
  429.             (make-built-in-wrapper-of-body-2 x var get-symbol))
  430.             (cdr tree))))
  431.       `(and (typep ,var ',(car tree))
  432.         ,(if sub-tests
  433.          `(or ,.sub-tests ,symbol)
  434.          symbol)))))
  435. )
  436.  
  437. (defun built-in-wrapper-of (x)
  438.   #.(make-built-in-wrapper-of-body))
  439.  
  440.  
  441.  
  442.  
  443. (eval-when (load eval)
  444.   (clrhash *find-class*)
  445.   (bootstrap-meta-braid)
  446.   (bootstrap-built-in-classes)
  447.   (setq *boot-state* 'braid)
  448.   (setf (symbol-function 'load-defclass) #'real-load-defclass)
  449.   )
  450.  
  451.  
  452. ;;;
  453. ;;; All of these method definitions must appear here because the bootstrap
  454. ;;; only allows one method per generic function until the braid is fully
  455. ;;; built.
  456. ;;;
  457. (defmethod print-object (instance stream)
  458.   (printing-random-thing (instance stream)
  459.     (let ((name (class-name (class-of instance))))
  460.       (if name
  461.       (format stream "~S" name)
  462.       (format stream "Instance")))))
  463.  
  464. (defmethod print-object ((class class) stream)
  465.   (named-object-print-function class stream))
  466.  
  467. (defmethod print-object ((slotd standard-slot-definition) stream)
  468.   (named-object-print-function slotd stream))
  469.  
  470. (defun named-object-print-function (instance stream
  471.                     &optional (extra nil extra-p))
  472.   (printing-random-thing (instance stream)
  473.     (if extra-p                    
  474.     (format stream "~A ~S ~:S"
  475.         (capitalize-words (class-name (class-of instance)))
  476.         (slot-value-or-default instance 'name)
  477.         extra)
  478.     (format stream "~A ~S"
  479.         (capitalize-words (class-name (class-of instance)))
  480.         (slot-value-or-default instance 'name)))))
  481.  
  482.  
  483. ;;;
  484. ;;;
  485. ;;;
  486. ;(defmethod shared-initialize :after ((class class) slot-names &key name)
  487. ;  (declare (ignore slot-names))
  488. ;  (setf (slot-value class 'name) name))
  489. ;
  490. ;
  491. ;(defmethod shared-initialize :after ((class std-class)
  492. ;                     slot-names
  493. ;                     &key direct-superclasses
  494. ;                      direct-slots)
  495. ; (declare (ignore slot-names))
  496. ; (setf (slot-value class 'direct-superclasses) direct-superclasses
  497. ;    (slot-value class 'direct-slots) direct-slots))
  498.  
  499. ;;;
  500. ;;;
  501. ;;;
  502. (defmethod shared-initialize :after ((slotd standard-slot-definition)
  503.                      slot-names
  504.                      &key class
  505.                       name
  506.                       initform
  507.                       initfunction
  508.                       initargs 
  509.                       (allocation :instance)
  510.                       (type t)
  511.                       readers
  512.                       writers)
  513.   (declare (ignore slot-names))
  514.   (setf (slot-value slotd 'name) name
  515.     (slot-value slotd 'initform) initform
  516.     (slot-value slotd 'initfunction) initfunction
  517.     (slot-value slotd 'initargs) initargs 
  518.     (slot-value slotd 'allocation) (if (eq allocation :class) class allocation)
  519.     (slot-value slotd 'type) type
  520.     (slot-value slotd 'readers) readers
  521.     (slot-value slotd 'writers) writers))
  522.  
  523.